home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 3b.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  57KB  |  1,849 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "3.h"
  11. #include "attr.h"
  12. #include "setp.h"
  13. #include "dclmapp.h"
  14. #include "errmsgp.h"
  15. #include "evalp.h"
  16. #include "nodesp.h"
  17. #include "miscp.h"
  18. #include "smiscp.h"
  19. #include "chapp.h"
  20.  
  21. static void new_unconstrained_array(Symbol, Node);
  22. static Symbol constrain_index(Symbol, Node);
  23. static void discr_decl(Node);
  24. static Tuple process_anons(Tuple);
  25. static int reformat_requires(Node);
  26.  
  27. Tuple apply_range(Node range_expr) /*;apply_range*/
  28. {
  29.     /* A'RANGE is equivalent to A'FIRST..A'LAST. When the range attribute
  30.      * is used as a constraint, the bounds are expressed according to the
  31.      * above equivalence. This is not strictly correct if the elaboration
  32.      * of A has side-effects, but we ignore this detail for now.
  33.      */
  34.  
  35.     Node    attr, arg1, arg2;
  36.     Tuple    new_c;
  37.     Node    l_node, f_node;
  38.     int    f, l, attr_kind;
  39.  
  40.     if (N_KIND(range_expr) == as_qual_range)
  41.         /* discard spurious constraint. */
  42.         range_expr = N_AST1(range_expr);
  43.     attr = N_AST1(range_expr);
  44.     arg1 = N_AST2(range_expr);
  45.     arg2 = N_AST3(range_expr);
  46.  
  47.     /* The attribute is either O_RANGE or T_RANGE, according as arg1 is an
  48.      * object or a type. FIRST and LAST must be marked accordingly.
  49.      */
  50.     /* In C note that base attribute kind followed by O_ kind, then T_. */
  51.     attr_kind = (int) attribute_kind(range_expr);
  52.  
  53.     if (attr_kind == ATTR_O_RANGE) {
  54.         f = ATTR_O_FIRST;
  55.         l = ATTR_O_LAST;
  56.     }
  57.     else {
  58.         f = ATTR_T_FIRST;
  59.         l = ATTR_T_LAST;
  60.     }
  61.  
  62.     f_node = new_attribute_node(f, arg1, arg2, N_TYPE(range_expr));
  63.     l_node = new_attribute_node(l, copy_tree(arg1), copy_tree(arg2),
  64.       N_TYPE(range_expr));
  65.  
  66.     N_KIND(range_expr) = as_range;
  67.     N_AST1(range_expr) = f_node;
  68.     N_AST2(range_expr) = l_node;
  69.  
  70.     /*return ?? ['range', f_node, l_node];*/
  71.     new_c = constraint_new(CONSTRAINT_RANGE);
  72.     numeric_constraint_low(new_c) = (char *) f_node;
  73.     numeric_constraint_high(new_c) = (char *) l_node;
  74.     return new_c;
  75. }
  76.  
  77. void array_typedef(Node node)                                /*;array_typedef*/
  78. {
  79.     Node index_list_node, type_indic_node;
  80.     Tuple index_nodes;
  81.     Node indx_node, indx1_node;
  82.     Tuple index_type_list;
  83.     Symbol    element_type;
  84.     int i, exists;
  85.     Fortup    ft1;
  86.  
  87.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : array_typedef");
  88.  
  89.     index_list_node = N_AST1(node);
  90.     type_indic_node = N_AST2(node);
  91.     sem_list(index_list_node);
  92.     index_nodes = N_LIST(index_list_node);
  93.  
  94.     index_type_list =  tup_new(tup_size(index_nodes));
  95.     FORTUPI(indx_node =(Node), index_nodes, i, ft1);
  96.         index_type_list[i] = (char *) make_index(indx_node);
  97.     ENDFORTUP(ft1);
  98.  
  99.     adasem(type_indic_node);
  100.     element_type = promote_subtype(make_subtype(type_indic_node));
  101.  
  102.     /* Validate an array type definition.*/
  103.  
  104.     exists = FALSE;
  105.     FORTUP(indx_node =(Node) , index_nodes, ft1);
  106.         if (N_KIND(indx_node) == as_box) {
  107.             exists = TRUE;
  108.             break;
  109.         }
  110.     ENDFORTUP(ft1);
  111.     if (exists) {
  112.         exists = FALSE;
  113.         /*Unconstrained array . Verify that all indices are unconstrained.*/
  114.         FORTUP(indx1_node = (Node), index_nodes, ft1);
  115.             if (N_KIND(indx1_node) != as_box) {
  116.                 exists = TRUE;
  117.                 break;
  118.             }
  119.         ENDFORTUP(ft1);
  120.         if (exists) {
  121.             errmsg("Constraints apply to all indices or none", "3.6.1", node);
  122.         }
  123.     }
  124.     if (is_unconstrained(element_type)) {
  125.         errmsg("Unconstrained element type in array declaration",
  126.           "3.6.1, 3.7.2", type_indic_node);
  127.     }
  128.     check_fully_declared2(element_type);
  129.  
  130.     for (i = 1; i<= tup_size(index_nodes); i++) {
  131.         Node tmp = (Node) index_nodes[i];
  132.         N_UNQ(tmp) = (Symbol) (index_type_list[i]);
  133.     }
  134.     N_UNQ(type_indic_node) = element_type;
  135. }
  136.  
  137. void new_array_type(Symbol array_type, Node def_node)  /*;new_array_type*/
  138. {
  139.     /* This     procedure  is    called    whenever  an array type is created.
  140.      * For each new array type we create a corresponding sequence type,
  141.      * which is an unconstrained  array. Unconstrained array types have
  142.      * nature na_array, while constrained arrays have nature na_subtype.
  143.      */
  144.  
  145.     Node    index_list_node;
  146.     Tuple    tn;
  147.     Node    tnn;
  148.  
  149.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_array_type(array_type");
  150.  
  151.     adasem(def_node);
  152.     index_list_node = N_AST1(def_node);
  153.  
  154.     tn =  N_LIST(index_list_node);
  155.     tnn = (Node) tn[1];
  156.     if (N_KIND(tnn) == as_box)
  157.         /* Unconstrained array definition. In this case, introduce only the*/
  158.         /* unconstrained type, and ignore the actual array type.*/
  159.         new_unconstrained_array(array_type, def_node);
  160.     else
  161.         new_constrained_array(array_type, def_node);
  162. }
  163.  
  164. static void new_unconstrained_array(Symbol sequence_type, Node def_node)
  165.                                                     /*;new_unconstrained_array*/
  166. {
  167.     Node index_list_node, type_indic_node, indx_node;
  168.     Fortup    ft1;
  169.     int    i, l;
  170.     Tuple    index_list, array_info;
  171.     Symbol    comp;
  172.  
  173.     index_list_node= N_AST1(def_node);
  174.     type_indic_node = N_AST2(def_node);
  175.     /*index_list := [N_UNQ(indx_node) : indx_node in N_LIST(index_list_node)];*/
  176.     index_list = tup_new(tup_size(N_LIST(index_list_node)));
  177.     FORTUPI(indx_node=(Node), N_LIST(index_list_node), i, ft1);
  178.         index_list[i] = (char *) N_UNQ(indx_node);
  179.     ENDFORTUP(ft1);
  180.     /*??array_info := [index_list, N_UNQ(type_indic_node)];*/
  181.     array_info = tup_new(2);
  182.     array_info[1] = (char *) index_list;
  183.     comp = N_UNQ(type_indic_node);
  184.     array_info[2] = (char *) comp;
  185.     /*SYMBTAB(sequence_type) := [na_array, sequence_type, array_info];*/
  186.     NATURE(sequence_type) = na_array;
  187.     TYPE_OF(sequence_type) = sequence_type;
  188.     SIGNATURE(sequence_type) = array_info;
  189.     /*Mark the type as limited if the component type is.*/
  190.     if (is_access(comp))
  191.         misc_type_attributes(sequence_type) = 0;
  192.     else {
  193.         l= (int) private_kind(comp);
  194.         misc_type_attributes(sequence_type) = l;
  195.     }
  196.     root_type(sequence_type) = sequence_type;
  197.     initialize_representation_info(sequence_type,TAG_ARRAY);
  198.  
  199.     /* For each unconstrained array type, we introduce an instance of the
  200.      * 'aggregate' pseudo-operator for that array.
  201.      */
  202.     new_agg_or_access_agg(sequence_type);
  203. }
  204.  
  205. void new_constrained_array(Symbol array_type, Node def_node)
  206.                                                     /*;new_constrained_array*/
  207. {
  208.     char    *nam;
  209.     Fortup    ft1;
  210.     Symbol    sequence_type;
  211.     Tuple    t, index_list, array_info;
  212.     Node    index_list_node, type_indic_node, indx_node;
  213.     int    i;
  214.     char    *sequence_type_name;
  215.  
  216.     /* Construct meaningful name for anonymous parent type.*/
  217.     nam = original_name(array_type);
  218.     if (strcmp(nam , "") == 0) nam = "anonymous_array";
  219.     sequence_type_name = strjoin(nam , strjoin("\'base" , newat_str()));
  220.     sequence_type = sym_new(na_void);
  221.     dcl_put(DECLARED(scope_name), sequence_type_name, sequence_type);
  222.     SCOPE_OF(sequence_type) = SCOPE_OF(array_type);
  223.     /* emit sequence type as an anonymous type. It is used in aggregates
  224.      * that are assigned to slices, and in other unconstrained contexts.
  225.      * (This should only be needed for one dimensional arrays).
  226.      */
  227.     /*top(NEWTYPES) with:= sequence_type;*/
  228.     t = (Tuple) newtypes[tup_size(newtypes)];
  229.     t = tup_with(t, (char *) sequence_type);
  230.     newtypes[tup_size(newtypes)] = (char *) t;
  231.     new_unconstrained_array(sequence_type, def_node);
  232.  
  233.     /* Make the actual array type into a subtype of the unconstrained one*/
  234.  
  235.     index_list_node = N_AST1(def_node);
  236.     type_indic_node = N_AST2(def_node);
  237.     index_list = tup_new(tup_size(N_LIST(index_list_node)));
  238.     FORTUPI(indx_node = (Node), N_LIST(index_list_node), i, ft1);
  239.         index_list[i] = (char *) N_UNQ(indx_node);
  240.     ENDFORTUP(ft1);
  241.     /*array_info := [index_list, N_UNQ(type_indic_node)];*/
  242.     array_info = tup_new(2);
  243.     array_info[1] = (char *) index_list;
  244.     array_info[2] = (char *) N_UNQ(type_indic_node);
  245.     /*??SYMBTAB(array_type) = [na_subtype, sequence_type, array_info];*/
  246.     NATURE(array_type) = na_subtype;
  247.     TYPE_OF(array_type) = sequence_type;
  248.     SIGNATURE(array_type) = array_info;
  249.     misc_type_attributes(array_type) = misc_type_attributes(sequence_type);
  250.     root_type(array_type) = sequence_type;
  251. }
  252.  
  253. Symbol anonymous_array(Node node) /*;anonymous_array*/
  254. {
  255.     /* Process an array definition in an object or constant declaration.
  256.      * The node is an array_type node.
  257.      */
  258.  
  259.     Symbol typ;
  260.     Tuple    t;
  261.  
  262.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : anonymous_array");
  263.  
  264.     typ =    find_new(strjoin("anon", newat_str()));      /*Create  a  name for it*/
  265.     new_array_type(typ, node);    /*elaborate   definition*/
  266.     /*??top(NEWTYPES) with:= typ;*/
  267.     /* Insert into type stack */
  268.     t = (Tuple) newtypes[tup_size(newtypes)];
  269.     t = tup_with(t, (char *) typ);
  270.     newtypes[tup_size(newtypes)] = (char *) t;
  271.     return typ;
  272. }
  273.  
  274. Symbol constrain_array(Symbol type_mark, Node constraint) /*;constrain_array*/
  275. {
  276.     int    i;
  277.     Symbol    new_array;
  278.     Tuple    indices, constraint_nodes, new_indices;
  279.  
  280.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  constrain_array");
  281.  
  282.     /* Apply index constraints to array type.*/
  283.  
  284.     if (! can_constrain(type_mark)) {
  285.         errmsg("Array type is already constrained", "3.6.1", constraint);
  286.         return symbol_any;
  287.     }
  288.  
  289.     if (N_LIST_DEFINED(N_KIND(constraint)))
  290.         constraint_nodes = N_LIST(constraint);
  291.     else
  292.         constraint_nodes = (Tuple)0;
  293.     if (constraint_nodes == (Tuple)0
  294.       || tup_size(constraint_nodes) != no_dimensions(type_mark)) {
  295.         errmsg_id("Incorrect no. of index constraints for type %", type_mark,
  296.           "3.6.1", constraint);
  297.         return symbol_any;
  298.     }
  299.  
  300.     if (constraint == OPT_NODE)
  301.         new_array = type_mark;
  302.     else {
  303.         /* apply constraints to each index type. */
  304.         indices = (Tuple) (index_types(type_mark) );
  305.         /* ??  new_indices = [constrain_index(indices(i), constraint_nodes(i)):
  306.          *   i in [1..#constraint_nodes]];
  307.          */
  308.         new_indices = tup_new(tup_size(constraint_nodes));
  309.         for (i = 1; i <= tup_size(constraint_nodes); i++)
  310.             new_indices[i] = (char *) constrain_index((Symbol) indices[i],
  311.               (Node) constraint_nodes[i]);
  312.     }
  313.  
  314.     new_array = anonymous_type();    /* Create  a  name for it*/
  315.     /* ??SYMBTAB(new_array):= [na_subtype, type_mark,
  316.      *     [new_indices, component_type(type_mark)]];
  317.      */
  318.     /* The signature should be in form of constraint. For now we
  319.      * will detect this case by nature na_subtype with signature
  320.      * being tuple of length two. This will be compatible with 
  321.      * uses of this signature.
  322.      */
  323.     NATURE(new_array) = na_subtype;
  324.     TYPE_OF(new_array) = type_mark;
  325.     { 
  326.         Tuple t;
  327.         t = tup_new(2);
  328.         t[1] = (char *) new_indices;
  329.         t[2] = (char *) component_type(type_mark);
  330.         SIGNATURE(new_array) = t;
  331.     }
  332.     root_type(new_array) = root_type(type_mark);
  333.     return new_array;
  334. }
  335.  
  336. Symbol make_index(Node subtype)                            /*;make_index*/
  337. {
  338.     /* Process an index  in an array declaration,  an entry family declara-
  339.      * tion, or a loop iteration. The index is given by an index declaration
  340.      * ( a 'box' ), or by a discrete range. The later can be  the name of a
  341.      * discrete type, or a subtype indication.
  342.      */
  343.  
  344.     Node    type_indic_node, constraint, lo, hi;
  345.     Symbol    typ, new_index, type_name;
  346.     Tuple    new_c;
  347.  
  348.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : make_index");
  349.  
  350.     if (N_KIND(subtype) == as_box) {
  351.         /* Unconstrained index definition. verify that the type_mark is*/
  352.         /* discrete. */
  353.         type_indic_node = N_AST1(subtype);
  354.         new_index = find_type(type_indic_node);
  355.  
  356.     }
  357.     else if (N_KIND(subtype) == as_range_attribute
  358.       || N_KIND(subtype) == as_attribute) {
  359.         /* The discrete range is given by a range attribute. Resolve as such.*/
  360.         N_KIND(subtype) = as_attribute;
  361.         find_old(subtype); 
  362.         check_type_d(subtype);
  363.         typ = N_TYPE(subtype);
  364.         new_index = anonymous_type();    /* Create  a  name for it*/
  365.         /*??SYMBTAB(new_index):=[na_subtype, typ, apply_range(subtype)];*/
  366.         NATURE(new_index) = na_subtype;
  367.         TYPE_OF(new_index) = typ;
  368.         SIGNATURE(new_index) = (Tuple) apply_range(subtype);
  369.         root_type(new_index) = root_type(typ);
  370.     }
  371.     else if (N_KIND(subtype) == as_name) {
  372.         type_indic_node = N_AST1(subtype);
  373.         new_index = find_type(type_indic_node);
  374.     }
  375.     else if (N_KIND(subtype) == as_subtype) {
  376.         /* the index is given by a subtype with a range constraint.*/
  377.  
  378.         type_indic_node = N_AST1(subtype);
  379.         constraint = N_AST2(subtype);
  380.  
  381.         lo = N_AST1(constraint);
  382.         hi = N_AST2(constraint);
  383.  
  384.         if (type_indic_node == OPT_NODE)
  385.             check_type_d(subtype);
  386.         else {            /* Type name is an identifier.*/
  387.             find_old(type_indic_node);
  388.             type_name = N_UNQ(type_indic_node);
  389.             check_type(base_type(type_name), subtype);
  390.         }
  391.         new_index = anonymous_type();    /* Create  a  name for it*/
  392.         typ     = N_TYPE(subtype);
  393.         /*SYMBTAB(new_index) = [na_subtype, typ, ['range', lo, hi]];*/
  394.         NATURE(new_index) = na_subtype;
  395.         TYPE_OF(new_index) = typ;
  396.         new_c = constraint_new(CONSTRAINT_RANGE);
  397.         numeric_constraint_low(new_c) = (char *) lo;
  398.         numeric_constraint_high(new_c) = (char *) hi;
  399.         SIGNATURE(new_index) = new_c;
  400.         root_type(new_index) = root_type(typ);
  401.     }
  402.     else {
  403.         errmsg("Invalid expression for index definition", "3.6.1", subtype);
  404.         return symbol_any;
  405.     }
  406.     /* Check that a type for the range was found, and that it is
  407.      * discrete, and generate an anonymous type for it.
  408.      */
  409.     if (noop_error)
  410.         /* Error message was emitted already. */
  411.         return  symbol_any;
  412.     else if (! is_discrete_type(new_index))     {
  413.         errmsg("expect discrete type in discrete range", "3.3, 3.6.1", subtype);
  414.         return  symbol_any;
  415.     }
  416.     return new_index;
  417. }
  418.  
  419. static Symbol constrain_index(Symbol index, Node constraint)/*;constrain_index*/
  420. {
  421.     /* Process an index constraint in a constrained array declaration.
  422.      * The constraint can be a subtype name, or a range with or without
  423.      * an explicit type mark. The index has been obtained from the signature
  424.      * of the unconstrained array.
  425.      */
  426.  
  427.     Node type_node, range_node, lo, hi;
  428.     Symbol    base_index, new_index, typ;
  429.     Tuple new_constraint;
  430.     int    nk;
  431.  
  432.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : constrain_index");
  433.  
  434.     base_index = base_type(index);
  435.     nk = N_KIND(constraint);
  436.  
  437.     if (nk == as_range_attribute) {
  438.         find_old(constraint);
  439.         N_KIND(constraint) = as_attribute;/* For resolution*/
  440.         check_type_d(constraint);
  441.  
  442.         typ = N_TYPE(constraint);
  443.         new_constraint = apply_range(constraint);
  444.  
  445.         if (! compatible_types(index, typ)) {
  446.             errmsg_id("Invalid index constraint for %", index, "3.6.1",
  447.               constraint);
  448.         }
  449.     }
  450.     else if (nk == as_subtype) {
  451.         /* The type name in the given constraint must be the same as the*/
  452.         /* original unconstrained index.*/
  453.         type_node = N_AST1(constraint);
  454.         range_node = N_AST2(constraint);
  455.         if (type_node == OPT_NODE) {
  456.             type_node = node_new(as_simple_name);
  457.             copy_span(range_node, type_node);
  458.             N_UNQ(type_node) = index;
  459.             N_AST1(constraint) = type_node;
  460.             N_AST2(constraint) = range_node;
  461.         }
  462.         else
  463.             find_old(type_node);
  464.         check_type(index, constraint);
  465.         lo = N_AST1(range_node);
  466.         hi = N_AST2(range_node);
  467.         /*new_constraint := ['range', lo, hi];*/
  468.         new_constraint = constraint_new(CONSTRAINT_RANGE);
  469.         numeric_constraint_low(new_constraint) = (char *) lo;
  470.         numeric_constraint_high(new_constraint) = (char *) hi;
  471.     }
  472.     else if (nk == as_range) {
  473.         /* In the case of allocator, the constraint appears as a range
  474.          * node, because syntactically it is just a name. Rebuild the
  475.          * node as a subtype of the index.
  476.          */
  477.  
  478.         type_node = node_new(as_simple_name);
  479.         copy_span(constraint, type_node);
  480.         N_UNQ(type_node) = index;
  481.         range_node = copy_node(constraint);
  482.         N_KIND(constraint) = as_subtype;
  483.         N_AST1(constraint)  = type_node;
  484.         N_AST2(constraint)  = range_node;
  485.  
  486.         check_type(index, constraint);
  487.         lo = N_AST1(range_node);
  488.         hi = N_AST2(range_node);
  489.         new_constraint = constraint_new(CONSTRAINT_RANGE);
  490.         numeric_constraint_low(new_constraint) = (char *) lo;
  491.         numeric_constraint_high(new_constraint) = (char *) hi;
  492.     }
  493.     else if (nk == as_name) {
  494.         type_node = N_AST1(constraint);
  495.         if (N_KIND(type_node) == as_attribute) {
  496.             find_old(constraint);
  497.             check_type(symbol_discrete_type, constraint);
  498.             typ = N_TYPE(constraint);
  499.             new_constraint = apply_range(constraint);
  500.             if (! compatible_types(index, typ) ) {
  501.                 errmsg_id("Invalid index constraint for %", index, "3.6.1",
  502.                   constraint);
  503.             }
  504.         }
  505.         else {
  506.             find_old(type_node);
  507.             new_index = N_UNQ(type_node);
  508.             if (! compatible_types(index, new_index) ) {
  509.                 errmsg_id("Invalid index constraint for %", index, "3.6.1",
  510.                   constraint);
  511.             }
  512.         }
  513.     }
  514.     else {
  515.         errmsg_id("Invalid index constraint for %", index, "3.6.1", constraint);
  516.         new_index = base_index;
  517.     }
  518.  
  519.     if (N_KIND(constraint) != as_name ) {
  520.         /* create anonymous type for index.*/
  521.         new_index = anonymous_type();
  522.         /*??SYMBTAB(new_index) := [na_subtype, index, new_constraint];*/
  523.         NATURE(new_index) = na_subtype;
  524.         TYPE_OF(new_index) = index;
  525.         SIGNATURE(new_index) = (Tuple) new_constraint;
  526.         root_type(new_index) = root_type(index);
  527.     }
  528.     return new_index;
  529. }
  530.  
  531. void record_decl(Symbol type_name, Node opt_disc, Node type_def)/*;record_decl*/
  532. {
  533.     /* Records constitute  a scope    for  the  component declarations within.
  534.      * The    scope is created prior to  the processing of these declarations.
  535.      * Discriminants  are  processed first, so  that  they are visible when
  536.      * processing the  other components. After the    discriminants have  been
  537.      * processed we set the nature of the type to na_record.
  538.      *
  539.      * If  an  incomplete or private  type declaration  was already given for
  540.      * the type, then this    scope already exists, and  the discriminants have
  541.      * been declared within. We must verify that the full declaration matches
  542.      * the    incomplete one.
  543.      */
  544.  
  545.     Node comp_list_node, comp_dec_node, variant_node;
  546.     Symbol n;
  547.     Fordeclared    div;
  548.     Symbol    comp;
  549.     int    l;
  550.     char    *str;
  551.     Tuple    rectup;
  552.  
  553.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : record_decl");
  554.  
  555.     newscope(type_name);
  556.     if (record_declarations(type_name) == (Tuple)0)
  557.         process_discr(type_name, opt_disc);
  558.     NATURE(type_name) = na_record;
  559.     TYPE_OF(type_name) = type_name;
  560.     root_type(type_name) = type_name;
  561.  
  562.     /* Now process remaining field declarations.*/
  563.     adasem(type_def);
  564.     comp_list_node = N_AST1(type_def);
  565.  
  566.     comp_dec_node = N_AST1(comp_list_node);
  567.     variant_node = N_AST2(comp_list_node);
  568.     /* use indices in next few assignments since cannot use macros
  569.      * invariant_part, variant_part and declared_components on left hand side 
  570.      */
  571.     rectup = SIGNATURE(type_name);
  572.     rectup[1] = (char *) comp_dec_node; /* invariant_part */
  573.     /*invariant_part(type_name) = (char *) comp_dec_node;*/
  574.     /*variant_part(type_name) = (char *) variant_node;*/
  575.     rectup[2] = (char *) variant_node;
  576.  
  577.     /*declared_components(type_name) = (char *) DECLARED(scope_name);*/
  578.     rectup[4] =  (char *) DECLARED(scope_name);
  579.     misc_type_attributes(type_name) = 0;
  580. #ifdef TBSL
  581.     -- in SETL, following qualified by 'if exists'. review this  ds 6-jan-85
  582. #endif
  583.     FORDECLARED(str, comp, (Declaredmap)DECLARED(scope_name), div)
  584.         l = private_kind(TYPE_OF(comp));
  585.         misc_type_attributes(type_name) = 
  586.           (int) misc_type_attributes(type_name) | l;
  587.         if  (l != 0) 
  588.             break;
  589.     ENDFORDECLARED(div)
  590.  
  591.     /* The nature of the record components is given as na_field while the
  592.      * record is being processed, in order to catch invalid dependencies
  593.      * among component declarations. Reset the nature  of each to 'obj'
  594.      * (except for discriminants of course).
  595.      */
  596.  
  597.     FORDECLARED(str, n, (Declaredmap)(DECLARED(scope_name)), div)
  598.         if (NATURE(n) == na_field)
  599.             NATURE(n) = na_obj;
  600.         else if (NATURE(n) == na_discriminant) {
  601.             /* constant folding of default values of discriminants is
  602.              * delayed until after conformance checks
  603.              */
  604.             eval_static((Node)default_expr(n));
  605.         }
  606.     ENDFORDECLARED(div)
  607.     popscope();            /* Exit record scope.*/
  608.  
  609.     /* For each record type we create an aggregate of the corresponding
  610.      * type.
  611.      */
  612.      initialize_representation_info(type_name,TAG_RECORD);
  613. #ifdef TBSL
  614.     not_chosen_put(type_name, (Symbol)0);
  615. #endif
  616.  
  617.     current_node = type_def;
  618.     new_agg_or_access_agg(type_name);
  619. }
  620.  
  621. void process_discr(Symbol type_name, Node opt_disc) /*;process_discr*/
  622. {
  623.     /* Process discriminants, or reprocess them in a full type declaration.
  624.      * Introduce the record scope. It is exited after the call, in type_decl
  625.      * or record decl, or private_decl.
  626.      */
  627.  
  628.     Tuple disc_names;
  629.     Node    discr_node, id_list_node, id_node;
  630.     Fortup    ft1, ft2;
  631.     int    i, has_default;
  632.     Tuple    rectup;
  633.  
  634.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  process_discr");
  635.  
  636.     record_declarations(type_name) = tup_new(5);
  637.     discr_decl(opt_disc);
  638.     /*discr_decl_tree(type_name) = (char *) opt_disc;*/
  639.     /* use index since cannot use discr_decl_tree macro on left     ds 31 dec 84*/
  640.     rectup = SIGNATURE(type_name);
  641.     rectup[5] = (char *) opt_disc;
  642.     if (opt_disc != OPT_NODE) {
  643.         /* add 'constrained' bit as additional discriminant in front.*/
  644.         disc_names = tup_new1((char *)symbol_constrained);
  645.  
  646.         FORTUP(discr_node =(Node), N_LIST(opt_disc), ft1 );
  647.             id_list_node = N_AST1(discr_node);
  648.             FORTUP(id_node =(Node), N_LIST(id_list_node), ft2);
  649.                 disc_names = tup_with(disc_names, (char *) N_UNQ(id_node));
  650.             ENDFORTUP(ft2);
  651.         ENDFORTUP(ft1);
  652.  
  653.         /* Check that all discriminants have default values, or none.*/
  654.         /* Omit constrained bit from this test.                      */
  655.         has_default = ((Node)default_expr((Symbol)disc_names[2]) != OPT_NODE);
  656.  
  657.         for (i = 3; i <= tup_size(disc_names); i++) {
  658.             if (((Node)(default_expr((Symbol)disc_names[i])) != OPT_NODE)
  659.               != has_default) {
  660.                 errmsg(
  661.                   "Incomplete specification of default vals for discriminants",
  662.                   "3.7.1", opt_disc);
  663.             }
  664.         }
  665.     }
  666.     else disc_names = tup_new(0);
  667.     /*discriminant_list(type_name) = (char *) disc_names;*/
  668.     rectup = SIGNATURE(type_name);
  669.     rectup[3] = (char *) disc_names;
  670.     /* Make names of discriminants visible at this point, because they may
  671.      * be used in constraints to other components of the current record type.
  672.      */
  673.     /*declared_components(type_name) = DECLARED(scope_name);*/
  674.     rectup[4] = (char *) DECLARED(scope_name);
  675. }
  676.  
  677. static void discr_decl(Node discr_list_node) /*;discr_decl*/
  678. {
  679.     /* Process discriminant declarations. Discriminants  are processed  like
  680.      * variable declarations, except that the type of a discriminant must be
  681.      * discrete,  and  the    nature    of  a  discriminant is, naturally enough
  682.      * na_discriminant. This insures that discriminants cannot appear on the
  683.      * left of an assignment, nor in expressions.
  684.      */
  685.  
  686.     Node discr_node, id_list_node, type_node, init_node, id_node;
  687.     Tuple id_nodes, nam_list;
  688.     Symbol type_mark, n;
  689.     int    i;
  690.     Fortup ft1, ft2;
  691.     Node    i_node, tmpnode, type_copy;
  692.  
  693.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  discr_decl");
  694.  
  695.     FORTUP(discr_node =(Node), N_LIST(discr_list_node), ft1);
  696.         id_list_node = N_AST1(discr_node);
  697.         type_node = N_AST2(discr_node);
  698.         init_node = N_AST3(discr_node);
  699.         id_nodes = N_LIST(id_list_node);
  700.         current_node = id_list_node;
  701.         nam_list = tup_new(tup_size(id_nodes));
  702.         FORTUPI(id_node=(Node), id_nodes, i, ft2);
  703.             nam_list[i] = (char *) find_new(N_VAL(id_node));
  704.         ENDFORTUP(ft2);
  705.         /* save original type_node for later conformance checks */
  706.         type_copy = copy_tree(type_node);
  707.         find_type(type_copy);
  708.         type_mark = N_UNQ(type_copy);
  709.  
  710.         if (! is_discrete_type(type_mark) ) {
  711.             errmsg("Discriminant must have discrete type", "3.7.1", type_node);
  712.             type_mark = symbol_any;
  713.         }
  714.  
  715.         if (init_node != OPT_NODE ) {
  716.             /* type check, but do not perform constant folding, for later
  717.               * conformance checks
  718.               */
  719.             i_node = copy_tree(init_node);
  720.             adasem(i_node);
  721.             normalize(type_mark, i_node);
  722.         }
  723.         else i_node = init_node;
  724.  
  725.         FORTUP(n =(Symbol), nam_list, ft2);
  726.             NATURE(n) = na_discriminant;
  727.             TYPE_OF(n) = type_mark;
  728.             SIGNATURE(n) = (Tuple) i_node;
  729.         ENDFORTUP(ft2);
  730.         for     (i = 1; i <= tup_size(id_nodes); i++) {
  731.             tmpnode = (Node) id_nodes[i];
  732.             N_UNQ(tmpnode) = (Symbol) nam_list[i];
  733.         }
  734.     ENDFORTUP(ft1);
  735. }
  736.  
  737. void discr_redecl(Symbol type_name, Node discr_list)    /*;discr_redecl */
  738. {
  739.     /* Verify conformance of discriminant part on redeclarations of types. */
  740.  
  741.     Node  node, old_node, old_discr_list, id_list, type_node, init_node;
  742.     Node  old_type_node, old_id_list, old_init_node;
  743.     Tuple discr_tup, old_discr_tup;
  744.     Symbol  discr;
  745.     int  i;
  746.  
  747.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  discr_redecl");
  748.  
  749.     old_discr_list = (Node) discr_decl_tree(type_name);
  750.  
  751.     if (!conform(discr_list, old_discr_list)) {
  752.         conformance_error(discr_list != OPT_NODE ? discr_list : current_node);
  753.         return;
  754.     }
  755.  
  756.     discr_tup = N_LIST(discr_list);
  757.     old_discr_tup = N_LIST(old_discr_list);
  758.     for (i = 1; i <= tup_size(old_discr_tup); i++) {
  759.         node = (Node) discr_tup[i];
  760.         old_node = (Node) old_discr_tup[i];
  761.         /* Pick a representatitive discriminant from current id list. */
  762.         old_id_list = N_AST1(old_node);
  763.         id_list = N_AST1(node);
  764.         discr = N_UNQ((Node)N_LIST(old_id_list)[1]);
  765.  
  766.         old_type_node = N_AST2(old_node);
  767.         type_node = N_AST2(node);
  768.         init_node = N_AST3(node);
  769.         old_init_node = N_AST3(old_node);
  770.         find_type(type_node);
  771.         if (N_UNQ(type_node) != TYPE_OF(discr))  {
  772.             conformance_error(type_node);
  773.             return;
  774.         } /* end if; */
  775.  
  776.         if (init_node != OPT_NODE) {
  777.             adasem(init_node);
  778.             normalize(N_UNQ(type_node), init_node);
  779.         }
  780.         /* Verify that the default values are the same.  */
  781.         if (!same_expn(init_node, (Node)default_expr(discr)) ) {
  782.             conformance_error(init_node == OPT_NODE ? node : init_node);
  783.             return;
  784.         }
  785.     }
  786. }
  787.  
  788. int same_expn(Node exp1, Node exp2)                     /*;same_expn */
  789. {
  790.     /* verify that two resolved expression trees designate the same entity,
  791.      * or evaluate to the same.
  792.      */
  793.  
  794.     int i, nk;
  795.     Tuple l1, l2;
  796.  
  797.     if (N_KIND(exp1) != N_KIND(exp2))
  798.         return FALSE;
  799.  
  800.     nk = N_KIND(exp1);
  801.     switch (nk) {
  802.     case (as_simple_name):
  803.         return (N_UNQ(exp1) == N_UNQ(exp2));
  804.     case (as_ivalue):
  805.         return const_eq((Const)N_VAL(exp1), (Const)N_VAL(exp2));
  806.     default:
  807.         if (N_AST1_DEFINED(nk) && (N_AST1(exp1) != (Node)0)) {
  808.             if (!same_expn(N_AST1(exp1), N_AST1(exp2)))
  809.                 return FALSE;
  810.             if (N_AST2_DEFINED(nk) && N_AST2(exp1) != (Node)0) {
  811.                 if (!same_expn(N_AST2(exp1), N_AST2(exp2)))
  812.                     return FALSE;
  813.                 if (N_AST3_DEFINED(nk) && N_AST3(exp1) != (Node)0) {
  814.                     if (!same_expn(N_AST3(exp1), N_AST3(exp2)))
  815.                         return FALSE;
  816.                     if (N_AST4_DEFINED(nk) && N_AST4(exp1) != (Node)0) {
  817.                         if (!same_expn(N_AST4(exp1), N_AST4(exp2)))
  818.                             return FALSE;
  819.                     }
  820.                 }
  821.             }
  822.         }
  823.         if (N_LIST_DEFINED(nk))
  824.             l1 = N_LIST(exp1);
  825.         else
  826.             l1 = (Tuple)0;
  827.         if (l1  != (Tuple)0 ) {
  828.             if (N_LIST_DEFINED(N_KIND(exp2)))
  829.                 l2 = N_LIST(exp2);
  830.             else
  831.                 l2 = (Tuple) 0;
  832.             if (l2 == (Tuple)0 || tup_size(l1) != tup_size(l2))
  833.                 return FALSE;
  834.             for (i = 1; i<= tup_size(l1); i++) {
  835.                 if (!same_expn((Node)l1[i], (Node)l2[i]))
  836.                     return FALSE;
  837.             }
  838.         }
  839.         return TRUE;        /* AST and LIST match. */
  840.     }
  841. }
  842.  
  843. void conformance_error(Node node)                 /*;conformance_error */
  844. {
  845.     errmsg("non conformance to previous declaration", "6.3.1", node);
  846. }
  847.  
  848. #ifdef TBSN
  849. Tuple bind_discr(Tuple discr_list)  /*;bind_discr*/
  850. {
  851.     /* The conformance rules  for  discriminant specifications require  the
  852.      * equality of the corresponding trees after name resolution and before
  853.      * constant  folding. (In fact, overload  resolution  may be  needed if
  854.      * function calls appear in the default expressions).
  855.      */
  856.     Tuple    t1, t2;
  857.     Fortup    ft1;
  858.     Tuple    res;
  859.     int    i;
  860.  
  861.     res = tup_new(tup_size(discr_list));
  862.     FORTUPI(t1=(Tuple), discr_list, i, ft1);
  863.         t2 = tup_new(4);
  864.         t2[1] = t1[1];
  865.         t2[2] = t1[2];
  866.         t2[3] = t1[3];
  867.         t2[4] = (char *) bind_names(t1[4]);
  868.         res[i] = (char *) t2;
  869.     ENDFORTUP(ft1);
  870.     return res;
  871. }
  872. #endif
  873.  
  874. void comp_decl(Node field_node) /*;comp_decl*/
  875. {
  876.     /* Process record component declaration.
  877.      * Verify that the type is a constrained one, or that default values
  878.      * exist for the discriminants of the type.
  879.      */
  880.  
  881.     Node id_list_node, type_indic_node, expn_node, id_node;
  882.     Tuple id_nodes, nam_list;
  883.     Symbol type_mark, t_m, n;
  884.     int        i;
  885.     Fortup    ft1;
  886.  
  887.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  comp_decl");
  888.  
  889.     id_list_node = N_AST1(field_node);
  890.     type_indic_node = N_AST2(field_node);
  891.     expn_node = N_AST3(field_node);
  892.  
  893.     id_nodes = N_LIST(id_list_node);
  894.     nam_list = tup_new(tup_size(id_nodes));
  895.     FORTUPI(id_node=(Node), id_nodes, i, ft1);
  896.         nam_list[i] = (char *) find_new(N_VAL(id_node));
  897.     ENDFORTUP(ft1);
  898.  
  899.     adasem(type_indic_node);
  900.     type_mark = promote_subtype(make_subtype(type_indic_node));
  901.     N_UNQ(type_indic_node) = type_mark;
  902.     check_fully_declared2(type_mark);
  903.     adasem(expn_node);
  904.  
  905.     /* Type-check the initial value, if provided.*/
  906.  
  907.     if (expn_node != OPT_NODE) {
  908.         t_m = check_init(type_indic_node, expn_node);
  909.         /* check_type(type_mark, expn_node); */
  910.     }
  911.  
  912.     /* Try to catch self-reference within a record type (a common mistake).*/
  913.     if (in_open_scopes(type_mark )) {
  914.         errmsg_nval("Invalid self-reference in definition of %",
  915.           type_indic_node, "3.1", type_indic_node);
  916.     }
  917.     if (is_unconstrained(type_mark)) {
  918.         errmsg_nat("Unconstrained % in component declaration", type_mark,
  919.           "3.6.1, 3.7.2", type_indic_node);
  920.     }
  921.  
  922.     FORTUP(n=(Symbol), nam_list, ft1);
  923.         NATURE(n) = na_field;
  924.         TYPE_OF(n) = type_mark;
  925.         SIGNATURE(n) = (Tuple) expn_node;
  926.     ENDFORTUP(ft1);
  927.  
  928.     for (i = 1; i <= tup_size(id_nodes); i++) {
  929.         Node tmp = (Node) id_nodes[i];
  930.         N_UNQ(tmp) = (Symbol) nam_list[i];
  931.     }
  932. }
  933.  
  934. Symbol constrain_record(Symbol type_mark, Node constraint) /*;constrain_record*/
  935. {
  936.     /* Process discriminant constraints of record type.
  937.      * Verify that values have been provided for all discriminants, that
  938.      * the original type is unconstrained, and that the types of the
  939.      * supplied expressions match the discriminant types.
  940.      */
  941.  
  942.     Symbol    d_name, typ;
  943.     Tuple d_list;
  944.     Tuple c_list, discr_map;
  945.     char *d_id;
  946.     Tuple d_seen;
  947.     /* TBSL: d_seen should be freed before return    ds 6-jan-85 */
  948.     Declaredmap comps;
  949.     Tuple constraint_list;
  950.     Node  ct, choice_list_node, choice_node, expn, name, nam, comp_assoc;
  951.     int i, first_named, exists, j, k, d_list_size;
  952.     Fortup    ft1, ft2;
  953.     Tuple    dconstraint;
  954.  
  955.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : constrain_record");
  956.  
  957.     if (! is_record(type_mark)) {
  958.         errmsg("Invalid type for constraint", "3.3, 3.7.2", constraint);
  959.         return symbol_any;
  960.     }
  961.     d_list = (Tuple) discriminant_list(type_mark);
  962.  
  963.     if(d_list == (Tuple)0 || tup_size(d_list) == 0) {
  964.         errmsg("Invalid constraint: Record type has no discriminant",
  965.           "3.7.1, 3.7.2", constraint);
  966.         return symbol_any;
  967.     }
  968.  
  969.     d_seen = tup_new(0);        /*To verify that all discriminants were*/
  970.     /* given values.*/
  971.  
  972.     constraint_list = N_LIST(constraint);
  973.  
  974.     /* Look for named associations in discriminant constraint list.*/
  975.  
  976.     exists = FALSE;
  977.     FORTUPI(ct = (Node), constraint_list, i, ft1);
  978.         if  (N_KIND(ct) == as_choice_list) {
  979.             exists = TRUE;
  980.             break;
  981.         }
  982.     ENDFORTUP(ft1);
  983.     if  (exists) {
  984.         first_named = i;
  985.         exists = FALSE;
  986.         for (j=i+1; j <= tup_size(constraint_list); j++) {
  987.             nam = (Node) constraint_list[j];
  988.             if ( N_KIND(nam) != as_choice_list ) {
  989.                 exists = TRUE;
  990.                 break;
  991.             }
  992.         }
  993.         if (exists) {
  994.             errmsg("Positional associations after named ones", "3.7.2", nam);
  995.             return symbol_any;
  996.         }
  997.     }
  998.     else
  999.         first_named = tup_size(constraint_list) + 1;
  1000.     d_list_size = tup_size(d_list);
  1001.     discr_map = tup_new(0);
  1002.  
  1003.     /* The constrained bit is treated like a discriminant, and the system
  1004.      * provides the initial constraint for it. This may be reset in the
  1005.      * expander. 
  1006.      */
  1007.     discr_map = discr_map_put(discr_map, symbol_constrained,
  1008.       new_ivalue_node(int_const(TRUE), symbol_boolean));
  1009.     d_seen = tup_with(d_seen, (char *) symbol_constrained);
  1010.  
  1011.     for (i = 1; i<first_named; i++) {
  1012.         if (i+1 > d_list_size) {    /* Exhausted discriminant list*/
  1013.             errmsg("Too many constraints for record type", "3.7.2",
  1014.               current_node);
  1015.             return symbol_any;
  1016.         }
  1017.         d_name = (Symbol) d_list[i+1];
  1018.         constraint = (Node) constraint_list[i];
  1019.         check_type(TYPE_OF(d_name), constraint);
  1020.         check_discriminant(constraint);
  1021.  
  1022.         if (N_TYPE(constraint) == symbol_any)  /* Type error occurred.*/
  1023.             ;
  1024.         else
  1025.             discr_map = discr_map_put(discr_map, d_name, constraint );
  1026.         if (!tup_mem( (char *) d_name, d_seen))
  1027.             d_seen = tup_with(d_seen, (char *)  d_name);
  1028.     }
  1029.  
  1030.     /* recall that in SETL
  1031.      * named_constraint = constraint_list(first_named..);
  1032.      * so can replace comp_assoc in named_constraint by following
  1033.      */
  1034.     for (j=first_named; j <= tup_size(constraint_list); j++) {
  1035.         comp_assoc = (Node) constraint_list[j];
  1036.         choice_list_node = N_AST1(comp_assoc);
  1037.         expn = N_AST2(comp_assoc);
  1038.         c_list = tup_new(0);    /* to collect names in this association.*/
  1039.  
  1040.         FORTUP(choice_node=(Node), N_LIST(choice_list_node), ft2);
  1041.             name = N_AST1(choice_node);
  1042.             if (N_KIND(choice_node) != as_choice_unresolved ) {
  1043.                 errmsg_l("Expect discriminant names only in discriminant",
  1044.                   " constraint", "3.7.1, 3.7.2", choice_node);
  1045.                 return    symbol_any;
  1046.             }
  1047.  
  1048.             d_id = N_VAL(name);
  1049.             comps = (Declaredmap) declared_components(type_mark);
  1050.             if (d_id == (char *)0  || (comps == (Declaredmap) 0)
  1051.               || (d_name = dcl_get(comps, d_id)) == (Symbol) 0
  1052.               || NATURE(d_name) != na_discriminant) {
  1053.                 errmsg("Invalid discriminant name in discriminant constraint",
  1054.                   "3.7. 3.7.2", choice_node);
  1055.                 return symbol_any;
  1056.             }
  1057.             if (tup_mem((char *) d_name, d_seen)) {
  1058.                 errmsg_str("Duplicate constraint for discriminant %",
  1059.                   d_id, "3.7.1, 3.7.2", choice_node);
  1060.             }
  1061.             else {
  1062.                 c_list = tup_with(c_list, (char *) d_name);
  1063.                 if (!tup_mem((char *) d_name, d_seen))
  1064.                     d_seen = tup_with(d_seen, (char *) d_name);
  1065.                 TO_XREF(d_name);
  1066.  
  1067.                 if (tup_size(c_list) == 1) {
  1068.                     /* need to resolve it only for the first in list */
  1069.                     check_type(TYPE_OF(d_name), expn);
  1070.                     check_discriminant(expn);
  1071.                 }
  1072.             }
  1073.         ENDFORTUP(ft2);
  1074.         discr_map = discr_map_put(discr_map, (Symbol) c_list[1], expn);
  1075.  
  1076.         for (k = 2; k <= tup_size(c_list); k++) {
  1077.             discr_map = discr_map_put(discr_map, (Symbol) c_list[k],
  1078.               copy_tree(expn));
  1079.             if (base_type(TYPE_OF((Symbol)c_list[k]))
  1080.               != base_type(TYPE_OF((Symbol)c_list[1]))) {
  1081.                 errmsg("discriminants in named association must have same type",
  1082.                   "3.7.2(4)", comp_assoc);
  1083.             }
  1084.         }
  1085.     }
  1086.     if (tup_size(d_seen) == tup_size(d_list)) { /* All discriminants were ok.*/
  1087.         typ = anonymous_type();         /* Create a name for it*/
  1088.         NATURE(typ) = na_subtype;
  1089.         TYPE_OF(typ) = type_mark;
  1090.         dconstraint = constraint_new(CONSTRAINT_DISCR);
  1091.         numeric_constraint_discr(dconstraint) = (char *) discr_map;
  1092.         SIGNATURE(typ) = (Tuple) dconstraint;
  1093.         root_type(typ) = type_mark;
  1094.         not_chosen_put(type_mark, typ);
  1095.         type_mark = typ;
  1096.     }
  1097.     else {
  1098.         errmsg("Missing constraints for discriminants", "3.7.2", constraint);
  1099.     }
  1100.     /* TBSL: free d_seen if defined        ds 6-jan-85*/
  1101.     return type_mark;
  1102. }
  1103.  
  1104. int check_discriminant(Node expn) /*;check_discriminant*/
  1105. {
  1106.     /* Verify that when a discriminant appears in an index constraint or a
  1107.      * discriminant constraint, it appears by itself and not as part of a
  1108.      * larger expression. The check is made after type checking, in which case
  1109.      * a constraint check may be applied on the node. The expression being
  1110.      * constrained may be a valid discriminant reference itself.
  1111.      */
  1112.  
  1113.     int    i, nk;
  1114.     Node    sub_expn;
  1115.     Fortup    ft;
  1116.  
  1117.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_discriminant");
  1118.  
  1119.     if (NATURE(scope_name) != na_record) return FALSE;
  1120.     if (N_KIND(expn) == as_simple_name) return FALSE;
  1121.  
  1122.     if ( (N_KIND(expn) == as_discr_ref) || (N_KIND(expn) == as_qual_range
  1123.       && N_KIND(N_AST1(expn)) == as_discr_ref))
  1124.         return TRUE;
  1125.     /* TBSN: check recoding of following loop over all AST subnodes*/
  1126.     nk = N_KIND(expn);
  1127.     for (i = 1; i <= 4; i++) {
  1128.         sub_expn = (Node)0;
  1129.         if (i == 1)
  1130.             if (N_AST1_DEFINED(nk)) sub_expn = N_AST1(expn);
  1131.         else if (i == 2)
  1132.             if (N_AST2_DEFINED(nk)) sub_expn = N_AST2(expn);
  1133.         else if (i == 3)
  1134.             if (N_AST3_DEFINED(nk)) sub_expn = N_AST3(expn);
  1135.         else if (i == 4)
  1136.             if (N_AST4_DEFINED(nk)) sub_expn = N_AST4(expn);
  1137.         if (sub_expn != (Node)0 && check_discriminant(sub_expn)) {
  1138.             errmsg_l("a discriminant appearing in a subtype indication ",
  1139.               "must appear by itself", "3.7.1", expn);
  1140.             return FALSE;        /*No need to propagate error.*/
  1141.         }
  1142.     }
  1143.     /* must also search through N_LIST */
  1144.     if (N_LIST_DEFINED(nk) && N_LIST(expn) != (Tuple)0) {
  1145.         FORTUP(sub_expn=(Node), N_LIST(expn), ft);
  1146.             if (check_discriminant(sub_expn)) {
  1147.                 errmsg_l("a discriminant appearing in a subtype indication ",
  1148.                   "must appear by itself", "3.7.1", expn);
  1149.                 return FALSE;        /*No need to propagate error.*/
  1150.             }
  1151.         ENDFORTUP(ft);
  1152.     }
  1153.     return FALSE;
  1154. }
  1155.  
  1156. void variant_decl(Node node)                                /*;variant_decl*/
  1157. {
  1158.     Node id_node, variant_list;
  1159.     Symbol    discr_name, dtyp;
  1160.  
  1161.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  variant_decl");
  1162.  
  1163.     id_node = N_AST1(node);
  1164.     variant_list = N_AST2(node);
  1165.  
  1166.     find_old(id_node);
  1167.     discr_name = N_UNQ(id_node);
  1168.     if (NATURE(discr_name) != na_discriminant) {
  1169.         errmsg("Invalid discriminant name in variant part", "3.7.1, 3.7.3", id_node);
  1170.         return;
  1171.     }
  1172.     else if ((dtyp = TYPE_OF(discr_name)) == (Symbol)0 )
  1173.         return;
  1174.     else
  1175.         process_case(dtyp, variant_list);
  1176. }
  1177.  
  1178. void incomplete_decl(Node node)                                /*;incomplete_decl*/
  1179. {
  1180.     Node    id_node, discr_list_node;
  1181.     char    *id;
  1182.     Symbol    name, old_name;
  1183.  
  1184.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  incomplete_decl");
  1185.  
  1186.     /* Process  an    incomplete  declaration. The  identifier  must    not  have
  1187.      * been declared already in the scope. However, an incomplete declaration
  1188.      * may    appear in  the private part of a package, for a private type that
  1189.      * has already been  declared. In  this case,  the discriminants (if any)
  1190.      * must match.
  1191.      */
  1192.  
  1193.     id_node = N_AST1(node);
  1194.     discr_list_node = N_AST2(node);
  1195.  
  1196.     sem_list(discr_list_node);
  1197.     id = N_VAL(id_node);
  1198.     old_name = dcl_get(DECLARED(scope_name), id);
  1199.     if (old_name == (Symbol)0 ) {
  1200.         name = find_new(id);
  1201.         N_UNQ(id_node) = name;
  1202.         TYPE_OF(name) = symbol_incomplete;
  1203.         root_type(name) = name;
  1204.         newscope(name);
  1205.         process_discr(name, discr_list_node);
  1206.         NATURE(name) = na_type;
  1207.         popscope();
  1208.     }
  1209.     else if (NATURE(scope_name) == na_private_part
  1210.       && (TYPE_OF(old_name) == symbol_private
  1211.       ||  TYPE_OF(old_name) == symbol_limited_private))
  1212.     {
  1213.         /* redeclaration of private type in private part.*/
  1214.         newscope(old_name);
  1215.         process_discr(old_name, discr_list_node);
  1216.         N_UNQ(id_node) = old_name;
  1217.         popscope();
  1218.     }
  1219.     else {
  1220.         errmsg_str("invalid redeclaration of %", id, "3.8, 8.2", id_node);
  1221.     }
  1222. }
  1223.  
  1224. void check_incomplete(Symbol type_mark)                      /*;check_incomplete*/
  1225. {
  1226.     /* Called to verify that an incomplete type is not used prematurely.*/
  1227.  
  1228.     if (TYPE_OF(base_type(type_mark)) == symbol_incomplete) {
  1229.         errmsg_id("Invalid use of type % before its full declaration",
  1230.           type_mark, "3.8.1", current_node);
  1231.     }
  1232. }
  1233.  
  1234. void declarative_part(Node node)                        /*;declarative_part*/
  1235. {
  1236.     /* Clean up list of declarations and generate nodes for anonymous types
  1237.      * that are created when elaborating subtype indications, etc.
  1238.      */
  1239.  
  1240.     Tuple    decl_nodes, type_list, anon_nodes, tup, id_list;
  1241.     Node    d, type_def, nam, component_list, invariant_node, init_node;
  1242.     Node    constraint, nod, id_node, subtype_indic, id_list_node;
  1243.     Fortup    ft1, ft2, ft3; 
  1244.     int        reformat;
  1245.     Node    type_indic_node, pnode, new_decl, a;
  1246.     Node    ancestor_node, decl_node, init;
  1247.  
  1248.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  declarative_part");
  1249.  
  1250.     decl_nodes = tup_new(0);
  1251.  
  1252.     FORTUP(d = (Node), N_LIST(node), ft1);
  1253.         if (N_KIND(d) == as_line_no) {     /* keep it for debugging */
  1254.             decl_nodes = tup_with(decl_nodes, (char *) d);
  1255.             continue;
  1256.         }
  1257.  
  1258.         /* For object and constant declarations create distinct declaration
  1259.          * nodes for each item in the id_list except in the case where the 
  1260.          * subtype indication is just a type mark. Complete constant decls.
  1261.          * are always expanded.
  1262.          */
  1263.         id_list_node    = N_AST1(d);
  1264.         type_indic_node = N_AST2(d);
  1265.         init_node       = N_AST3(d);
  1266.  
  1267.         if (N_KIND(d) == as_const_decl) reformat = TRUE;
  1268.  
  1269.         else if (N_KIND(d) == as_obj_decl ) {
  1270.             if (N_KIND(type_indic_node) == as_subtype_indic ) {
  1271.                 /* if subtype indication carries explicit constraint,
  1272.                  * must elaborate each declaration separately.
  1273.                    * (This latter is a little bit to strict.
  1274.                  * In a declaration like :
  1275.                    * type ARR is array (integer range <>) of integer;
  1276.                     * A, B, C : ARR (1..100);
  1277.                   * There is no need to split (reformat) this declaration.
  1278.                  * This reformat generates 3 types and therefore 3
  1279.                  * 3 type templates 
  1280.                  */
  1281.                 reformat = (N_AST2(type_indic_node) != OPT_NODE)
  1282.                   && reformat_requires (type_indic_node);
  1283.             }
  1284.             else        /* anonymous array.*/
  1285.                 reformat = TRUE;
  1286.         }
  1287.         else reformat = FALSE;
  1288.  
  1289.         if (reformat) {
  1290.             id_list = N_LIST(id_list_node);
  1291.             FORTUP(id_node = (Node), id_list, ft2);
  1292.                 new_decl = d;
  1293.                 if (tup_size(id_list) > 1) {
  1294.                     new_decl = copy_tree(d);
  1295.                     N_LIST(N_AST1(new_decl)) = tup_new1((char *) id_node);
  1296.                 }
  1297.                 newtypes = tup_with(newtypes, (char *) tup_new(0));
  1298.                 /* To collect anonymous types*/
  1299.                 adasem(new_decl);
  1300.                 type_list = (Tuple) tup_frome(newtypes);
  1301.                 FORTUP(pnode = (Node), process_anons(type_list), ft3);
  1302.                     decl_nodes = tup_with(decl_nodes, (char *)  pnode);
  1303.                 ENDFORTUP(ft3);
  1304.                 decl_nodes = tup_with(decl_nodes, (char *) new_decl);
  1305.                 /* A declaration like "a : array_type := (aggregate or
  1306.                  * qualification)" is split in two parts : a simple
  1307.                  * declaration, followed by an assignment.  The reason is the
  1308.                  * following : In the previous version there was a call to
  1309.                  * "array_ivalue", which makes a call to "compute_index".
  1310.                  * This is done to copy each component of the aggregate to its
  1311.                  * position in the array "a".  But, this can lead to incorrect
  1312.                  * results or to a constraint_error (incorrect subscript) in
  1313.                  * case of array sliding (the following assignement has to be
  1314.                  * performed : a (i) := aggregate (i + drift) instead of  a (i)
  1315.                  * := aggregate (i) ).  The solution we have chosen is the
  1316.                  * simplest and requires very little modifications.
  1317.                  */
  1318.                 if (init_node != OPT_NODE
  1319.                   && (N_AST2_DEFINED(N_KIND(type_indic_node)))
  1320.                   && (N_AST2(type_indic_node) != OPT_NODE)
  1321.                   && (is_record(TYPE_OF(N_UNQ(id_node)))
  1322.                   || (is_array(TYPE_OF(N_UNQ(id_node)))
  1323.                   && ((N_KIND (init_node) == as_qualify)
  1324.                   || (N_KIND (init_node) == as_array_aggregate))))) {
  1325.                     /* split object elaboration from actual assignment of
  1326.                     * initial value to constrained records
  1327.                     */
  1328.                     init = new_assign_node(copy_node(id_node),
  1329.                         N_AST3(new_decl));
  1330.                     N_AST3(new_decl) = OPT_NODE;
  1331.                     decl_nodes = tup_with(decl_nodes, (char *) init);
  1332.                 }
  1333.             ENDFORTUP(ft2);
  1334.             continue;
  1335.         }
  1336.         else {
  1337.             newtypes = tup_with(newtypes, (char *) tup_new(0));
  1338.             /* To collect anonymous types*/
  1339.             adasem(d);
  1340.             type_list  = (Tuple) tup_frome(newtypes);
  1341.             /* Create (sub)type declaration nodes for the anonymous types.*/
  1342.             anon_nodes = process_anons(type_list);
  1343.         }
  1344.     
  1345.         /* For record types, the anonymous types generated (which  may depend
  1346.          * on discriminants) are attached to the invariant part of the record
  1347.          * declaration, so that they may be emitted and elaborated within the
  1348.          * record.
  1349.           */
  1350.         if (N_KIND(d) == as_type_decl) {
  1351.             id_node = N_AST1(d);
  1352.             type_def = N_AST3(d);
  1353.             if (N_KIND(type_def) == as_record) {
  1354.                 component_list = N_AST1(type_def);
  1355.                 invariant_node = N_AST1(component_list);
  1356.                 FORTUP(a=(Node), anon_nodes, ft2);
  1357.                     if (N_KIND(a) == as_subtype_decl) {
  1358.                         nam = N_AST1(a);
  1359.                         if (TYPE_OF(N_UNQ(nam)) == N_UNQ(id_node)) {
  1360.                             /* We have an anonymous subtype of the current
  1361.                              * record type declaration. Mark it as a delayed
  1362.                              * type also.
  1363.                              */
  1364.                             decl_node = copy_node(a);
  1365.                             N_KIND(a) = as_delayed_type;
  1366.                             ancestor_node = new_name_node(N_UNQ(id_node));
  1367.                             N_AST1(a) = nam;
  1368.                             N_AST2(a) = ancestor_node;
  1369.                             N_AST3(a) = decl_node;
  1370.                         }
  1371.                     }
  1372.                 ENDFORTUP(ft2);
  1373.                 /* N_LIST(invariant_node) := anon_nodes */
  1374.                 /*    + N_LIST(invariant_node); */
  1375.                 tup = anon_nodes;
  1376.                 FORTUP(nod = (Node), N_LIST(invariant_node), ft2);
  1377.                     tup = tup_with(tup, (char *) nod);
  1378.                 ENDFORTUP(ft2);
  1379.                 N_LIST(invariant_node) = tup;
  1380.             }
  1381.             else {
  1382.                 /*decl_nodes +:= anon_nodes;*/
  1383.                 FORTUP(nod = (Node), anon_nodes, ft2);
  1384.                     decl_nodes = tup_with(decl_nodes, (char *) nod);
  1385.                 ENDFORTUP(ft2);
  1386.             }
  1387.         }
  1388.         else if (N_KIND(d) == as_subtype_decl) {
  1389.             id_node = N_AST1(d);
  1390.             subtype_indic = N_AST2(d);
  1391.             constraint = N_AST2(subtype_indic);
  1392.             if (constraint == OPT_NODE && !is_scalar_type(N_UNQ(id_node)) ) {
  1393.                 /* The subtype is a renaming of its parent, and does not 
  1394.                  *  appear in the code. Ignore the node.
  1395.                   */
  1396.                 /*    tup_free(anon_nodes);*/
  1397.                 continue;
  1398.             }
  1399.             else {
  1400.                 if (is_array(N_UNQ(id_node)) || (is_record(N_UNQ(id_node)))) {
  1401.                     /* discard anonymous array or record subtype to avoid 
  1402.                       * double elaboration 
  1403.                       */
  1404.                     nod = (Node) tup_frome(anon_nodes);
  1405.                     if (N_KIND (nod) != as_subtype_decl) {
  1406.                         /*  the last node may be a type declaration: case 
  1407.                           *  of derived type and therefore must not be removed 
  1408.                            */
  1409.                         anon_nodes = tup_with (anon_nodes, (char *) nod); 
  1410.                     }
  1411.                 }
  1412.                 /*decl_nodes +:= anon_nodes;*/
  1413.                 FORTUP(nod=(Node), anon_nodes, ft2);
  1414.                     decl_nodes = tup_with(decl_nodes, (char *) nod);
  1415.                 ENDFORTUP(ft2);
  1416.             }
  1417.         }
  1418.         else if (N_KIND(d) == as_num_decl ) {
  1419.             /* This represents declaration of a static universal constant
  1420.               *  which can be removed from the tree, since it needs to be noted 
  1421.               * only in the symbol table. The ivalue node representing the actual
  1422.               * value will be picked up by collect_unit_nodes.
  1423.               */
  1424.             continue;
  1425.         }
  1426.         else if (N_KIND(d) == as_rename_ex) {
  1427.             /* This represents a renaming of an exception which is handled
  1428.               * strictly in the symbol table and no longer needs to be in the
  1429.               * tree, so it is removed.
  1430.               */
  1431.             continue;
  1432.         }
  1433.         else {
  1434.             /*decl_nodes +:= anon_nodes;*/
  1435.             FORTUP(nod = (Node), anon_nodes, ft2);
  1436.                 decl_nodes = tup_with(decl_nodes, (char *) nod);
  1437.             ENDFORTUP(ft2);
  1438.         }
  1439.  
  1440.         decl_nodes = tup_with(decl_nodes, (char *) d);
  1441.         /*tup_free(anon_nodes);*/
  1442.     ENDFORTUP(ft1);
  1443.     N_LIST(node) = decl_nodes;
  1444. }
  1445.  
  1446. static Tuple process_anons(Tuple type_list)                    /*;process_anons*/
  1447. {
  1448.     Symbol    t;
  1449.     Node    nam, decl;
  1450.     Fortup    ft1;
  1451.     Tuple    anon_nodes;
  1452.  
  1453.     /* Create (sub)type declaration nodes for the anonymous types.*/
  1454.     anon_nodes = tup_new(0);
  1455.  
  1456.     FORTUP(t=(Symbol), type_list, ft1);
  1457.         nam = node_new(as_simple_name);
  1458.         N_UNQ(nam) = t;
  1459.         decl = node_new( NATURE(t) == na_subtype ? as_subtype_decl
  1460.           : as_type_decl );
  1461.         N_AST1(decl) = nam;
  1462.         N_AST2(decl) = OPT_NODE;
  1463.         if (N_KIND(decl) == as_type_decl)
  1464.             N_AST3(decl) = OPT_NODE;
  1465.         check_delayed_type(decl, t);
  1466.         anon_nodes = tup_with(anon_nodes, (char *)  decl );
  1467.     ENDFORTUP(ft1);
  1468.     return anon_nodes;
  1469. }
  1470.  
  1471. Symbol promote_subtype(Symbol subtype)                    /*;promote_subtype*/
  1472. {
  1473.     /* This     procedure is  called when a  subtype  indication  produces  an
  1474.      * anonymous type.  This occurs     when processing an object, constant or
  1475.      * subtype  declaration, when  processing  an iteration     scheme, or the
  1476.      * range  of an entry  family.    If the subtype is  already a type name,
  1477.      * it is returned as is.  If a previous subtype with the same structure
  1478.      * in the same scope was already promoted,  then that one  is returned.
  1479.      * Otherwise, the type mark is placed in the NEWTYPES stack, and atta-
  1480.      * ched to the current declaration.
  1481.      */
  1482.  
  1483.     Symbol parent_type;
  1484.     Tuple    t;
  1485.  
  1486.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  promote_subtype");
  1487.  
  1488.     if (! is_anonymous(subtype)) return subtype;
  1489.  
  1490.     t =(Tuple) newtypes[tup_size(newtypes)];
  1491.     /*TBSL see if can reallocate tuple in top(top...) calculation below */
  1492.     if (!tup_mem((char *) subtype, t))
  1493.         newtypes[tup_size(newtypes)] = (char *) tup_with(t, (char *) subtype);
  1494.     parent_type = TYPE_OF(subtype);
  1495.     root_type(subtype) = root_type(parent_type);
  1496.     misc_type_attributes(subtype) = misc_type_attributes(parent_type);
  1497.     return subtype;
  1498. }
  1499.  
  1500. Tuple subtype_expr(Symbol name)                            /*;subtype_expr*/
  1501. {
  1502.     /* OBSOLETE: used to generate AIS, return null tuple. */
  1503.  
  1504.     if (cdebug2 > 3) TO_ERRFILE("AT PROC: subtype_expr");
  1505.     return tup_new(0);
  1506. }
  1507.  
  1508. int is_character_type(Symbol name)                         /*;is_character_type*/
  1509. {
  1510.     /* An enumeration type is a character type if it contains at least one
  1511.      * character literal.
  1512.      */
  1513.  
  1514.     Symbol    bt;
  1515.     char        *c;
  1516.     int    i;
  1517.     Tuple    tup;
  1518.  
  1519.     if ( root_type(name) == symbol_character ) return TRUE;
  1520.     bt = base_type(name);
  1521.     if (NATURE(bt)    != na_enum) return FALSE;
  1522.     tup = (Tuple) literal_map(bt);
  1523.     for (i = 1; i <= tup_size(tup); i += 2) {
  1524.         c = tup[i];
  1525.         if (strlen(c) == 3 &&c[0] == '\'' && c[2] == '\'') return TRUE;
  1526.     }
  1527.     return FALSE;
  1528. }
  1529.  
  1530. int is_discrete_type(Symbol name) /*;is_discrete_type*/
  1531. {
  1532.     Symbol    btype;
  1533.  
  1534.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_discrete_type");
  1535.  
  1536.     if (TYPE_OF(name) != (Symbol)0) btype = root_type(name);
  1537.     else return FALSE;
  1538.  
  1539.     if (btype == symbol_integer
  1540.       || btype== symbol_universal_integer
  1541.       || btype == symbol_discrete_type
  1542.       || btype == symbol_any) return TRUE;
  1543.     if (NATURE(btype) == na_enum ) return TRUE;
  1544.     return FALSE;
  1545. }
  1546.  
  1547. int is_numeric(Symbol name)                                      /*;is_numeric*/
  1548. {
  1549.     Symbol r;
  1550.  
  1551.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_numeric");
  1552.  
  1553.     /* ??const numeric_types = {'INTEGER', 'FLOAT', '$FIXED',
  1554.      *  'universal_integer', 'universal_fixed', 'universal_real'};
  1555.      * return (root_type(name) ??in numeric_types );
  1556.      */
  1557.     r = root_type(name);
  1558.     return (r == symbol_integer || r == symbol_float 
  1559.       || is_fixed_type(r) || r == symbol_universal_integer
  1560.       || r == symbol_universal_real || r == symbol_universal_fixed );
  1561. }
  1562.  
  1563. int is_incomplete_type(Symbol t)                  /*;is_incomplete_type*/
  1564. {
  1565.     /* A type is incomplete if only an incomplete type declaration for it
  1566.      * has been seen, or if one of its subcomponents is an incomplete private
  1567.      * type (because of other rules, a subcomponent can never have an
  1568.      * incomplete type).
  1569.      */
  1570.  
  1571.     Symbol    b;
  1572.  
  1573.     b = base_type(t);
  1574.     return (TYPE_OF(b) == symbol_incomplete
  1575.       || private_ancestor(b) != (Symbol)0);
  1576. }
  1577.  
  1578. int is_unconstrained(Symbol typ)                     /*;is_unconstrained*/
  1579. {
  1580.     Symbol    discr;
  1581.     Fortup    ft1;
  1582.  
  1583.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_unconstrained");
  1584.  
  1585.     /*TBSL: check translation of this*/
  1586.     if    (NATURE(typ) == na_array) return TRUE;
  1587.     if (NATURE(typ) != na_record ) 
  1588.         if(!in_incp_types(TYPE_OF(typ))) return FALSE;
  1589.     /* Some discriminant has no default value.*/
  1590.     FORTUP(discr=(Symbol), (Tuple) discriminant_list(typ), ft1);
  1591.         if (discr == symbol_constrained) continue;
  1592.         if ((Node) default_expr(discr) == OPT_NODE ) return TRUE;
  1593.     ENDFORTUP(ft1);
  1594.     return FALSE;
  1595. }
  1596.  
  1597. Symbol base_type(Symbol name) /*;base_type*/
  1598. {
  1599.     Symbol    b;
  1600.  
  1601.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  base_type");
  1602.  
  1603.     /* It is possible to define subtypes of scalar subtypes. The base type
  1604.      * is then obtained by following the subtype chain until we reach a type
  1605.      */
  1606.     if (NATURE(name) == na_subtype) {
  1607.         b = TYPE_OF(name);
  1608.         while (NATURE(b) == na_subtype && b != name) {
  1609.             name = b;
  1610.             b = TYPE_OF(name);
  1611.         }
  1612.         return b;
  1613.     }
  1614.     else if (NATURE(name) == na_record || NATURE(name) == na_array)
  1615.         /* The type_of the array is its base type (it can be itself).*/
  1616.         return TYPE_OF(name);
  1617.     else
  1618.         return name;
  1619. }
  1620.  
  1621. Symbol named_type(char *name)  /*;named_type*/
  1622. {
  1623.     /* calls corresponding to the SETL named_type(str newat) send  & as first
  1624.      * character, so that they can be detected by the macro is_anonymous
  1625.      */
  1626.  
  1627.     Symbol    type_name;
  1628.     static int tint=0;
  1629.  
  1630.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  named_type");
  1631.  
  1632.     /* This procedure is invoked when an anonymous type can be given a name
  1633.      * that relates to its nature (e.g the base type of a derived type).
  1634.      */
  1635.     /* this is now obsolete -- newat_str() has already generated a unique string
  1636.      *    tint +=1;
  1637.      *    name = emalloc(6); -- t + 4 digits + null 
  1638.      *    sprintf(name, "t%04d", tint);
  1639.      */
  1640.     type_name =  sym_new(na_type);
  1641.     ORIG_NAME(type_name) = name;
  1642.     dcl_put(DECLARED(scope_name), name, type_name);
  1643.     SCOPE_OF(type_name) = scope_name;
  1644.     return type_name;
  1645. }
  1646.  
  1647. Symbol anonymous_type()                                     /*;anonymous_type*/
  1648. {
  1649.     /* This procedure is called to produce a new identifier for an anonymous
  1650.      * type. The new identifier is inserted into the symbol table, and into
  1651.      * the type stack.
  1652.      */
  1653.  
  1654.     Symbol    new_name;
  1655.     Tuple    t;
  1656.  
  1657.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  anonymous_type");
  1658.  
  1659.     new_name = named_atom("&anon");
  1660.     dcl_put(DECLARED(scope_name), str_newat(), new_name );
  1661.     SCOPE_OF(new_name) = scope_name;
  1662.     t = (Tuple) newtypes[tup_size(newtypes)];
  1663.     newtypes[tup_size(newtypes)] = (char *) tup_with(t, (char *) new_name);
  1664.     return new_name;
  1665. }
  1666.  
  1667. Symbol named_atom(char *id)                                     /*;named_atom*/
  1668. {
  1669.     /* This procedure uses the unique name generated for a compilation
  1670.      * unit to produce new names that will be unique throughout a library,
  1671.      * especially one containing more than one AIS file.
  1672.      */
  1673.     /* In C this returns a Symbol - the details of naming it are to
  1674.      * be resolved later        ds 4 aug
  1675.      */
  1676.  
  1677.     Symbol    s;
  1678.  
  1679.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  named_atom");
  1680.  
  1681.     s = sym_new(na_void);
  1682.     ORIG_NAME(s) = strjoin(id, "");
  1683.     return s;
  1684. #ifdef TBSN
  1685.     ??     return
  1686.  
  1687.         if unit_name(1) = 'body' then 'UB:' else '' end
  1688.     +/[unit_name(i) + '.' : i in [#unit_name, #unit_name-1..3]]
  1689.         + unit_name(2)
  1690.         + if unit_name(2) = '' then '' else '.' end
  1691.         + id
  1692.         + str newat;
  1693. #endif
  1694. }
  1695.  
  1696. int is_static_expr(Node node)                             /*;is_static_expr*/
  1697. {
  1698.     /* note - use statc since static is C keyword */
  1699.     int    statc, nat, nk;
  1700.     Fortup    ft1;
  1701.     Node    parm_node, gen_agg, aggregate, expression, opn;
  1702.     Node    arg2, attr, type_node;
  1703.     int    attrkind;
  1704.     Symbol n, prefix_type;
  1705.  
  1706.     if (cdebug2 > 3) TO_ERRFILE("AT PROC:is_static_expr ");
  1707.  
  1708.     if (N_TYPE(node) == symbol_any)    /* previous error */
  1709.         return TRUE;
  1710.  
  1711.     nk = N_KIND(node);
  1712.  
  1713.     if (nk == as_ivalue  || nk == as_int_literal
  1714.       || nk == as_real_literal || nk == as_character_literal)
  1715.         statc = TRUE;
  1716.     else if (nk == as_simple_name) {
  1717.         nat = NATURE(N_UNQ(node));
  1718.         if (nat == na_literal) statc = TRUE;
  1719.         else if (nat == na_constant)
  1720.             statc = is_static_expr((Node) SIGNATURE(N_UNQ(node)));
  1721.         else
  1722.             statc = FALSE;
  1723.     }
  1724.     else if (nk == as_un_op || nk == as_op) {
  1725.         statc = TRUE;
  1726.         opn = N_AST1(node);
  1727.         gen_agg = N_AST2(node);
  1728.         if ((N_UNQ(opn) == symbol_andthen)
  1729.           || (N_UNQ(opn) == symbol_orelse))
  1730.             statc = FALSE;
  1731.         FORTUP(parm_node =(Node), N_LIST(gen_agg), ft1);
  1732.             if (! is_static_expr(parm_node))
  1733.                 statc = FALSE;
  1734.         ENDFORTUP(ft1);
  1735.     }
  1736.     else if (nk == as_attribute) {
  1737.         attr = N_AST1(node);
  1738.         type_node = N_AST2(node);
  1739.         arg2 = N_AST3(node);
  1740.         attrkind = (int) attribute_kind(node);
  1741.  
  1742.         if (attrkind == ATTR_O_RANGE
  1743.           || attrkind == ATTR_T_RANGE
  1744.           || attrkind == ATTR_RANGE
  1745.           || attrkind == ATTR_O_LENGTH
  1746.           || attrkind == ATTR_T_LENGTH
  1747.           || attrkind == ATTR_LENGTH
  1748.           || attrkind == ATTR_FIRST_BIT
  1749.           || attrkind == ATTR_LAST_BIT
  1750.           || attrkind == ATTR_POSITION
  1751.           || attrkind == ATTR_TERMINATED
  1752.           || attrkind == ATTR_COUNT
  1753.           || attrkind == ATTR_CONSTRAINED
  1754.           || attrkind == ATTR_STORAGE_SIZE )
  1755.             return FALSE;
  1756.  
  1757.         if (N_KIND(type_node) != as_simple_name)
  1758.             prefix_type = N_TYPE(type_node);
  1759.         else {
  1760.             n = N_UNQ(type_node);
  1761.             if (is_type(n))
  1762.                 prefix_type = n;
  1763.             else
  1764.                 prefix_type = TYPE_OF(n);
  1765.         }
  1766.         if (is_generic_type(prefix_type))
  1767.             statc = FALSE;
  1768.         else {
  1769.             if (attrkind == ATTR_O_FIRST
  1770.               || attrkind == ATTR_T_FIRST
  1771.               || attrkind == ATTR_FIRST
  1772.               || attrkind == ATTR_O_LAST
  1773.               || attrkind == ATTR_T_LAST
  1774.               || attrkind == ATTR_LAST) {
  1775.                 if (is_array(prefix_type) )
  1776.                     statc = FALSE;
  1777.                 else
  1778.                     statc = is_static_subtype(prefix_type);
  1779.             }
  1780.             else if (attrkind == ATTR_POS
  1781.               || attrkind == ATTR_VAL 
  1782.               || attrkind == ATTR_SUCC
  1783.               || attrkind == ATTR_PRED
  1784.               || attrkind == ATTR_IMAGE
  1785.               || attrkind == ATTR_VALUE ) {
  1786.                 statc = is_static_subtype(prefix_type) &
  1787.                   is_static_expr(arg2);
  1788.             }
  1789.             else if (attrkind == ATTR_SIZE) {
  1790.                 if (N_KIND(type_node) == as_attribute 
  1791.                   && (int) attribute_kind(type_node) == ATTR_RANGE)
  1792.                     errmsg("Invalid argument for attribute SIZE", "Annex A",
  1793.                       type_node);
  1794.                 statc = is_static_subtype(prefix_type);
  1795.             }
  1796.             else
  1797.                 /* May need further refinement. */
  1798.                 statc = TRUE;
  1799.         }
  1800.     }
  1801.     else if (nk == as_range_attribute)
  1802.         statc = FALSE;
  1803.     else if (nk == as_qualify) {
  1804.         /*type_mark = N_AST1(node); set but never used    ds 18 aug*/
  1805.         aggregate = N_AST2(node);
  1806.         statc = is_static_expr(aggregate);
  1807.     }
  1808.     else if (nk == as_parenthesis || nk == as_qual_range) {
  1809.         expression = N_AST1(node);
  1810.         statc = is_static_expr(expression);
  1811.     }
  1812.     else
  1813.         statc = FALSE;
  1814.  
  1815.     return statc;
  1816. }
  1817.  
  1818. /* the following function return FALSE if we have an array object
  1819.     declaration whose index subtypes are static. This will avoid
  1820.     the generation of n types (and n types templates) where n is
  1821.     the size of the object list */
  1822.  
  1823. static int reformat_requires(Node node_param) /*;reformat_requires*/
  1824. {
  1825.     Node    node, node1, ln;
  1826.     Fortup ftp1;
  1827.  
  1828.     if (N_KIND (node_param) == as_subtype_indic) {
  1829.         node = N_AST2 (node_param);
  1830.         if (N_KIND (node) != as_constraint ) 
  1831.             return TRUE; 
  1832.         if (N_LIST (node) == (Tuple) 0) 
  1833.             return TRUE; 
  1834.         FORTUP (ln= (Node), N_LIST (node), ftp1);
  1835.             if (N_KIND (ln) != as_subtype)
  1836.                 return TRUE;
  1837.             node1 = N_AST2 (ln);
  1838.             if (N_KIND (node1) != as_range) 
  1839.                 return TRUE;
  1840.             if (!is_static_expr (N_AST1 (node1))
  1841.               || !is_static_expr (N_AST2 (node1)))
  1842.                 return TRUE;
  1843.         ENDFORTUP (ftp1);
  1844.         return FALSE;
  1845.     }
  1846.     else
  1847.         return TRUE;
  1848. }
  1849.